home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / IMAIN.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  17.4 KB  |  700 lines
  1. #if !COMPILER
  2. /*
  3.  * File: imain.r
  4.  * Interpreter main program, argument handling, and such.
  5.  * Contents: main, icon_call, icon_setup, resolve, xmfree
  6.  */
  7.  
  8. #include "../h/version.h"
  9. #include "../h/header.h"
  10. #include "../h/opdefs.h"
  11.  
  12. /*
  13.  * Prototypes.
  14.  */
  15.  
  16. hidden    novalue    env_err    Params((char *msg,char *name,char *val));
  17. hidden    novalue    icon_setup    Params((int argc, char **argv, int *ip));
  18.  
  19. /*
  20.  * The following code is operating-system dependent [@imain.01].  Declarations
  21.  *   that are system-dependent.
  22.  */
  23.  
  24. #if PORT
  25.    /* probably needs something more */
  26. Deliberate Syntax Error
  27. #endif                    /* PORT */
  28.  
  29. #if MACINTOSH
  30. #if MPW
  31. int NoOptions = 0;
  32. #endif                    /* MPW */
  33. #endif                    /* MACINTOSH */
  34.  
  35. #if AMIGA || ARM || ATARI_ST || MSDOS || MVS || VM || OS2 || UNIX\
  36.    || VMS
  37.    /* nothing needed */
  38. #endif                    /* AMIGA || ARM || ATARI_ST ... */
  39.  
  40. /*
  41.  * End of operating-system specific code.
  42.  */
  43.  
  44. #ifdef MemMon
  45.  
  46. extern FILE *monfile;
  47.  
  48. char *monfname;
  49. #endif                    /* MemMon */
  50.  
  51. #ifndef MaxHeader
  52. #define MaxHeader MaxHdr
  53. #endif                    /* MaxHeader */
  54.  
  55. /*
  56.  * A number of important variables follow.
  57.  */
  58.  
  59. int n_globals = 0;            /* number of globals */
  60. int n_statics = 0;            /* number of statics */
  61.  
  62. #ifdef TraceBack
  63. #endif                    /* TraceBack */
  64.  
  65.  
  66. #ifdef IconCalling
  67. int IDepth = 0;                /* depth of icon_call calls */
  68. int call_error = 0;            /* called procedure not found */
  69. int interp_status;            /* interpreter status */
  70. #endif                    /* IconCalling */
  71.  
  72. int set_up = 0;                /* initialization switch */
  73.  
  74.  
  75. /*
  76.  * Initial icode sequence. This is used to invoke the main procedure with one
  77.  *  argument.  If main returns, the Op_Quit is executed.
  78.  */
  79. word istart[3];
  80. int mterm = Op_Quit;
  81.  
  82. #ifdef IconCalling
  83. int fterm = Op_FQuit;
  84. #endif                    /* IconCalling */
  85.  
  86. #ifndef IconCalling
  87.  
  88.  
  89. novalue main(argc, argv)
  90.  
  91. int argc;
  92. char **argv;
  93.    {
  94.    int i, slen;
  95.  
  96. #if AMIGA
  97. #if AZTEC_C
  98.    struct Process *FindTask();
  99.    struct Process *Process = FindTask(0L);
  100.    ULONG stacksize = *((ULONG *)Process->pr_ReturnAddr);
  101.  
  102.    if (stacksize < ICONXMINSTACK) {
  103.       fprintf(stderr,"Iconx needs \"stack %d\" to run\n",ICONXMINSTACK);
  104.       exit(-1);
  105.       }
  106. #endif                    /* AZTEC_C */
  107. #endif                    /* AMIGA */
  108.  
  109. #if SASC
  110.    quiet(1);                    /* suppress C library diagnostics */
  111. #endif                    /* SASC */
  112.  
  113.    ipc.opnd = NULL;
  114.  
  115. #if VMS
  116.    redirect(&argc, argv, 0);
  117. #endif                    /* VMS */
  118.  
  119.    /*
  120.     * Setup Icon interface.  It's done this way to avoid duplication
  121.     *  of code, since the same thing has to be done if calling Icon
  122.     *  is enabled.  See istart.c.
  123.     */
  124.  
  125. #ifdef CRAY
  126.    argv[0] = "iconx";
  127. #endif                    /* CRAY */
  128.  
  129.    icon_setup(argc, argv, &i);
  130.  
  131.    if (i < 0) {
  132.       argc++;
  133.       argv--;
  134.       i++;
  135.       }
  136.  
  137.    while (i--) {            /* skip option arguments */
  138.       argc--;
  139.       argv++;
  140.       }
  141.  
  142.    if (!argc) 
  143.       error("no icode file specified");
  144.    /*
  145.     * Call icon_init with the name of the icode file to execute.    [[I?]]
  146.     */
  147.  
  148.  
  149.    icon_init(argv[1]);
  150.  
  151.    /*
  152.     *  Point sp at word after b_coexpr block for &main, point ipc at initial
  153.     *    icode segment, and clear the gfp.
  154.     */
  155.  
  156.    stackend = stack + mstksize/WordSize;
  157.    sp = stack + Wsizeof(struct b_coexpr);
  158.  
  159.    ipc.opnd = istart;
  160.    *ipc.op++ = Op_Invoke;                /*    [[I?]] */
  161.  
  162. #if AMIGA
  163.    istart[0] = Op_Invoke;
  164.    istart[1] = 1;
  165.    istart[2] = Op_Quit;
  166. #else                    /* AMIGA */
  167.    *ipc.opnd++ = 1;
  168.    *ipc.op = Op_Quit;
  169.    ipc.opnd = istart;
  170. #endif                    /* AMIGA */
  171.  
  172.    gfp = 0;
  173.  
  174.    /*
  175.     * Set up expression frame marker to contain execution of the
  176.     *  main procedure.  If failure occurs in this context, control
  177.     *  is transferred to mterm, the address of an Op_Quit.
  178.     */
  179.    efp = (struct ef_marker *)(sp);
  180.    efp->ef_failure.op = &mterm;
  181.    efp->ef_gfp = 0;
  182.    efp->ef_efp = 0;
  183.    efp->ef_ilevel = 1;
  184.    sp += Wsizeof(*efp) - 1;
  185.  
  186.    pfp = 0;
  187.    ilevel = 0;
  188.  
  189. /*
  190.  * We have already loaded the
  191.  * icode and initialized things, so it's time to just push main(),
  192.  * build an Icon list for the rest of the arguments, and called
  193.  * interp on a "invoke 1" bytecode.
  194.  */
  195.    /*
  196.     * The first global variable holds the value of "main".  If it
  197.     *  is not of type procedure, this is noted as run-time error 117.
  198.     *  Otherwise, this value is pushed on the stack.
  199.     */
  200.    if (globals[0].dword != D_Proc)
  201.       fatalerr(117, NULL);
  202.    PushDesc(globals[0]);
  203.    PushNull;
  204.    argp = (dptr)(sp - 1);
  205.  
  206.    /*
  207.     * If main() has a parameter, it is to be invoked with one argument, a list
  208.     *  of the command line arguments.  The command line arguments are pushed
  209.     *  on the stack as a series of descriptors and Ollist is called to create
  210.     *  the list.  The null descriptor first pushed serves as Arg0 for
  211.     *  Ollist and receives the result of the computation.
  212.     */
  213.  
  214.    if (((struct b_proc *)BlkLoc(globals[0]))->nparam > 0) {
  215.       for (i = 2; i < argc; i++) {
  216.          char *tmp;
  217.          slen = strlen(argv[i]);
  218.          PushVal(slen);
  219.          Protect(tmp=alcstr(argv[i],(word)slen), fatalerr(0,NULL));
  220.          PushAVal(tmp);
  221.          }
  222.  
  223.       Ollist(argc - 2, argp);
  224.       }
  225.  
  226.  
  227.    sp = (word *)argp + 1;
  228.    argp = 0;
  229.  
  230.    set_up = 1;            /* post fact that iconx is initialized */
  231.  
  232.    /*
  233.     * Start things rolling by calling interp.  This call to interp
  234.     *  returns only if an Op_Quit is executed.    If this happens,
  235.     *  c_exit() is called to wrap things up.
  236.     */
  237.  
  238. #ifdef CoProcesses
  239.    codisp();    /* start up co-expr dispatcher, which will call interp */
  240. #else                    /* CoProcesses */
  241.    interp(0,(dptr)NULL);                        /*      [[I?]] */
  242. #endif                    /* CoProcesses */
  243.  
  244.    c_exit(NormalExit);
  245. }
  246. #endif                    /* IconCalling */
  247.  
  248. #ifdef IconCalling
  249. /*
  250.  * icon_call - call an Icon procedure from a C program.
  251.  */
  252. dptr icon_call(pname, argc, dargv)
  253. char *pname;
  254. int argc;
  255. dptr dargv;
  256. {
  257.    int i;
  258.    dptr retdesc;
  259.    struct descrip pd;
  260.  
  261. #if SASC
  262.    quiet(1);                    /* suppress C library diagnostics */
  263. #endif                    /* SASC */
  264.  
  265.    if (IDepth == 0)
  266.       {
  267.       /*
  268.        * Perform first-time initializations.
  269.        *  Point sp at word after b_coexpr block for &main, point ipc at initial
  270.        *  icode segment, and clear the gfp.
  271.        */
  272.       stackend = stack + mstksize/WordSize;
  273.       sp = stack + Wsizeof(struct b_coexpr);
  274.       sp--;   /* point at last thing on stack, not beyond it */
  275.  
  276.       interp_status = 0;
  277.       argp = 0;
  278.       pfp = 0;
  279.       ilevel = 0;
  280.       }
  281.  
  282.    /*
  283.     *  Point sp at word after b_coexpr block for &main, point ipc at initial
  284.     *    icode segment, and clear the gfp.
  285.     */
  286.    ipc.opnd = istart;
  287.    *ipc.op++ = Op_Invoke;
  288.    *ipc.opnd++ = argc;            /* number of arguments for call */
  289.    *ipc.op = Op_Quit;
  290.  
  291.    ipc.opnd = istart;
  292.    gfp = 0;
  293.  
  294.    /*
  295.     * Set up expression frame marker to contain execution of the
  296.     *  main procedure.    If failure occurs in this context, control
  297.     *  is transferred to fterm, the address of an Op_FQuit.
  298.     */
  299.    efp = (struct ef_marker *)(sp + 1);
  300.    efp->ef_failure.op = &fterm;     /* signals a failure to interp */
  301.    efp->ef_gfp = 0;
  302.    efp->ef_efp = 0;
  303.    efp->ef_ilevel = ilevel + 1;
  304.    sp += Wsizeof(*efp);
  305.  
  306.    /*
  307.     * "main" is no longer the default starting procedure.
  308.     *  Use procedure named pname as the main (starting) procedure.
  309.     */
  310.    if (getvar(pname,&pd) == Failed) {
  311.       fprintf(stderr, "Icon function/procedure \"%s\" not found\n", pname);
  312.       fflush(stderr);
  313.       call_error = 1;
  314.       return (dptr)NULL;
  315.       }
  316.    Deref(pd);            /* get value (can't fail) */
  317.  
  318.    /*
  319.     * Must be of type procedure.
  320.     */
  321.    if ((pd.dword != D_Proc)) { 
  322.       if (strcmp(pname,"main") == 0 && (pfp == 0))
  323.          fatalerr(117, NULL);
  324.       else {
  325.          if (pfp == 0)
  326.             fatalerr(106, NULL);
  327.          else
  328.             fatalerr(106, NULL);
  329.          }
  330.       }
  331.  
  332.    PushDesc(pd);
  333.  
  334.    /*
  335.     * The input arguments are pushed on the stack as a series
  336.     *  of descriptors and the indicated procedure.  The procedure descriptor
  337.     *  is overwritten with the result of the call.
  338.     */
  339.    for (i = 0; i < argc; i++) {           /* i = 0, instead of 2 */
  340.       PushDesc(dargv[i]);
  341.       }
  342.  
  343. /* Pass on value of argp to current invocation.  This will be 0 by
  344.  *  default on the first action, and the value of the current argp on
  345.  *  subsequent invocations.
  346.  */
  347.  
  348.    /*
  349.     * Start things rolling by calling interp.  This call to interp
  350.     *  returns only if an Op_Quit is executed.    If this happens,
  351.     *  return the result of main. (Used to c_exit here).
  352.     */
  353.    IDepth++;
  354.  
  355. #ifdef CoProcesses
  356.    codisp();        /* start up co-expr dispatcher, which calls interp */
  357. #else                    /* CoProcesses */
  358.    interp(0,(dptr)NULL);
  359. #endif                    /* CoProcesses */
  360.  
  361.    IDepth--;
  362.    if (interp_status == A_Pfail_uw)
  363.        return (dptr)NULL;        /* failure no value */
  364.    else                    /* NOTE: suspension not identified */
  365.        {
  366.        retdesc = (dptr)(sp - 1);
  367.        sp = (word *) efp - 1;
  368.        return retdesc;             /* success, return top sp */
  369.        }
  370.  
  371. }
  372. #endif                     /* IconCalling */
  373.  
  374. /*
  375.  * icon_setup - handle interpreter command line options.
  376.  */
  377. static novalue icon_setup(argc,argv,ip)
  378. int argc;
  379. char **argv;
  380. int *ip;
  381.    {
  382.  
  383. #ifdef TallyOpt
  384.    extern int tallyopt;
  385. #endif                    /* TallyOpt */
  386.  
  387.    *ip = 0;            /* number of arguments processed */
  388.  
  389. #ifdef ExecImages
  390.    if (dumped) {
  391.       /*
  392.        * This is a restart of a dumped interpreter.  Normally, argv[0] is
  393.        *  iconx, argv[1] is the icode file, and argv[2:(argc-1)] are the
  394.        *  arguments to pass as a list to main().  For a dumped interpreter
  395.        *  however, argv[0] is the executable binary, and the first argument
  396.        *  for main() is argv[1].  The simplest way to handle this is to
  397.        *  back up argv to point at argv[-1] and increment argc, giving the
  398.        *  illusion of an additional argument at the head of the list.  Note
  399.        *  that this argument is never referenced.
  400.        */
  401.       argv--;
  402.       argc++;
  403.       (*ip)--;
  404.       }
  405. #endif                    /* ExecImages */
  406.  
  407. #ifdef MaxLevel
  408.    maxilevel = 0;
  409.    maxplevel = 0;
  410.    maxsp = 0;
  411. #endif                    /* MaxLevel */
  412.  
  413. #if MACINTOSH
  414. #if MPW
  415.    InitCursorCtl(NULL);
  416.    /*
  417.     * To support the icode and iconx interpreter bundled together in
  418.     * the same file, we might have to use this code file as the icode
  419.     * file, too.  We do this if the command name is not 'iconx'.
  420.     */
  421.    {
  422.    char *p,*q,c,fn[6];
  423.  
  424.    /*
  425.     * Isolate the filename from the path.
  426.     */
  427.    q = strrchr(*argv,':');
  428.    if (q == NULL)
  429.        q = *argv;
  430.    else
  431.        ++q;
  432.    /*
  433.     * See if it's the real iconx -- case independent compare.
  434.     */
  435.    p = fn;
  436.    if (strlen(q) == 5)
  437.       while (c = *q++) *p++ = tolower(c);
  438.    *p = '\0';
  439.    if (strcmp(fn,"iconx") != 0) {
  440.      /*
  441.       * This technique of shifting arguments relies on the fact that
  442.       * argv[0] is never referenced, since this will make it invalid.
  443.       */
  444.       --argv;
  445.       ++argc;
  446.       --(*ip);
  447.       /*
  448.        * We don't want to look for any command line options in this
  449.        * case.  They could interfere with options for the icon
  450.        * program.
  451.        */
  452.       NoOptions = 1;
  453.       }
  454.    }
  455. #endif                    /* MPW */
  456. #endif                                  /* MACINTOSH */
  457.  
  458. /*
  459.  * Handle command line options.
  460. */
  461. #if MACINTOSH && MPW
  462.    if (!NoOptions)
  463. #endif                    /* MACINTOSH && MPW */
  464.    while ( argv[1] != 0 && *argv[1] == '-' ) {
  465.       switch ( *(argv[1]+1) ) {
  466.  
  467. #ifdef TallyOpt
  468.     /*
  469.      * Set tallying flag if -T option given
  470.      */
  471.     case 'T':
  472.         tallyopt = 1;
  473.         break;
  474. #endif                    /* TallyOpt */
  475.  
  476. #ifdef MemMon
  477.     /*
  478.      * Check for command-line event monitor enable
  479.      */
  480.     case 'E': {
  481.         char *p;
  482.         if ( *(argv[1]+2) != '\0' )
  483.            p = argv[1]+2;
  484.         else {
  485.            argv++;
  486.            argc--;
  487.                (*ip)++;
  488.            p = argv[1];
  489.            if ( !p )
  490.           error("no file name given for event monitor file");
  491.            }
  492.         monfname = p;
  493.         break;
  494.         }
  495. #endif            /* MemMon */
  496.  
  497.  
  498.       /*
  499.        * Set stderr to new file if -e option is given.
  500.        */
  501.      case 'e': {
  502.         char *p;
  503.         if ( *(argv[1]+2) != '\0' )
  504.            p = argv[1]+2;
  505.         else {
  506.            argv++;
  507.            argc--;
  508.                (*ip)++;
  509.            p = argv[1];
  510.            if ( !p )
  511.           error("no file name given for redirection of &errout");
  512.            }
  513.             if (!redirerr(p))
  514.                syserr("Unable to redirect &errout\n");
  515.         break;
  516.         }
  517.         }
  518.     argc--;
  519.         (*ip)++;
  520.     argv++;
  521.       }
  522.    }
  523.  
  524. /*
  525.  * resolve - perform various fix-ups on the data read from the icode
  526.  *  file.
  527.  */
  528. novalue resolve()
  529.  
  530.    {
  531.    register word i, j;
  532.    register struct b_proc *pp;
  533.    register dptr dp;
  534.    extern Omkrec();
  535.    extern int ftsize;
  536.  
  537.  
  538.    /* delete this Xfer */
  539.  
  540.  
  541. #ifdef EventMon
  542.    if (EventStream)
  543.       fprintf(monfile,"%d(\n",C_Symbols);
  544. #endif                    /* EventMon */
  545.  
  546.    /*
  547.     * Relocate the names of the global variables.
  548.     */
  549.    for (dp = gnames; dp < egnames; dp++)
  550.       StrLoc(*dp) = strcons + (uword)StrLoc(*dp);
  551.  
  552.    /*
  553.     * Scan the global variable array for procedures and fill in appropriate
  554.     *  addresses.
  555.     */
  556.    for (j = 0; j < n_globals; j++) {
  557.  
  558. #ifdef EventMon
  559.       EVFnc(j);
  560. #endif                    /* EventMon */
  561.  
  562.       if (globals[j].dword != D_Proc)
  563.          continue;
  564.  
  565.       /*
  566.        * The second word of the descriptor for procedure variables tells
  567.        *  where the procedure is.  Negative values are used for built-in
  568.        *  procedures and positive values are used for Icon procedures.
  569.        */
  570.       i = IntVal(globals[j]);
  571.  
  572.       if (i < 0) {
  573.          /*
  574.           * globals[j] points to a built-in function; call (bi_)strprc
  575.       *  to look it up by name in the interpreter's table of built-in
  576.       *  functions.
  577.           */
  578.      if((BlkLoc(globals[j])= (union block *)bi_strprc(gnames+j,0)) == NULL)
  579.             globals[j] = nulldesc;        /* undefined, set to &null */
  580.          }
  581.       else {
  582.  
  583.          /*
  584.           * globals[j] points to an Icon procedure or a record; i is an offset
  585.           *  to location of the procedure block in the code section.  Point
  586.           *  pp at the block and replace BlkLoc(globals[j]).
  587.           */
  588.          pp = (struct b_proc *)(code + i);
  589.          BlkLoc(globals[j]) = (union block *)pp;
  590.  
  591.          /*
  592.           * Relocate the address of the name of the procedure.
  593.           */
  594.          StrLoc(pp->pname) = strcons + (uword)StrLoc(pp->pname);
  595.  
  596.  
  597.          if (pp->ndynam == -2) {
  598.             /*
  599.              * This procedure is a record constructor.    Make its entry point
  600.              *    be the entry point of Omkrec().
  601.              */
  602.             pp->entryp.ccode = Omkrec;
  603.  
  604. #ifdef FieldNames
  605.         /*
  606.          * Initialize field names
  607.          */
  608.             for (i = 0; i < pp->nfields; i++)
  609.                StrLoc(pp->lnames[i]) = strcons + (uword)StrLoc(pp->lnames[i]);
  610. #endif                    /* FieldNames */
  611.  
  612.         }
  613.          else {
  614.             /*
  615.              * This is an Icon procedure.  Relocate the entry point and
  616.              *    the names of the parameters, locals, and static variables.
  617.              */
  618.             pp->entryp.icode = code + pp->entryp.ioff;
  619.             for (i = 0; i < abs((int)pp->nparam)+pp->ndynam+pp->nstatic; i++)
  620.                StrLoc(pp->lnames[i]) = strcons + (uword)StrLoc(pp->lnames[i]);
  621.             }
  622.  
  623.          }
  624.  
  625.       }
  626.  
  627.    /*
  628.     * Relocate the names of the fields.
  629.     */
  630.  
  631.    for (dp = fnames; dp < efnames; dp++)
  632.       StrLoc(*dp) = strcons + (uword)StrLoc(*dp);
  633.  
  634.  
  635. #ifdef EventMon
  636.    if (EventStream)
  637.       fprintf(monfile,"%d)\n%d(",C_Symbols,C_Eval);
  638. #endif                    /* EventMon */
  639.    }
  640.  
  641.  
  642. /*
  643.  * Free malloc-ed memory; the main regions then co-expressions.  Note:
  644.  *  this is only correct if all allocation is done by routines that are
  645.  *  compatible with free() -- which may not be the case if Allocreg()
  646.  *  in rmemfix.c is defined to be other than malloc().
  647.  */
  648.  
  649. novalue xmfree()
  650.    {
  651. #ifdef FixedRegions
  652.    register struct b_coexpr **ep, *xep;
  653.    register struct astkblk *abp, *xabp;
  654.  
  655.    if (mainhead != (struct b_coexpr *)NULL)
  656.       free((pointer)mainhead->es_actstk);    /* activation block for &main */
  657.    free((pointer)code);            /* icode */
  658.    code = NULL;
  659.    free((pointer)stack);        /* interpreter stack */
  660.    stack = NULL;
  661.    free((pointer)strbase);        /* allocated string region */
  662.    strbase = NULL;
  663.    free((pointer)blkbase);        /* allocated block region */
  664.    blkbase = NULL;
  665.    free((pointer)quallist);        /* qualifier list */
  666.    quallist = NULL;
  667.  
  668.    /*
  669.     * The co-expression blocks are linked together through their
  670.     *  nextstk fields, with stklist pointing to the head of the list.
  671.     *  The list is traversed and each stack is freeing.
  672.     */
  673.    ep = &stklist;
  674.    while (*ep != NULL) {
  675.       xep = *ep;
  676.       *ep = (*ep)->nextstk;
  677.        /*
  678.         * Free the astkblks.  There should always be one and it seems that
  679.         *  it's not possible to have more than one, but nonetheless, the
  680.         *  code provides for more than one.
  681.         */
  682.       for (abp = xep->es_actstk; abp; ) {
  683.             xabp = abp;
  684.             abp = abp->astk_nxt;
  685.             free((pointer)xabp);
  686.             }
  687.  
  688. #if CoProcesses
  689.          coswitch(BlkLoc(k_current)->coexpr.cstate, xep->cstate, -1);
  690.                 /* terminate coproc for coexpression first */
  691. #endif                    /* CoProcesses */
  692.  
  693.       free((pointer)xep);
  694.    stklist = NULL;
  695.    }
  696. #endif                    /* Fixed Regions */
  697.  
  698.    }
  699. #endif                    /* !COMPILER */
  700.